home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / progjrn / pj_7_5.arc / GRAPHWLD.PAS < prev    next >
Pascal/Delphi Source File  |  1989-06-08  |  7KB  |  256 lines
  1. {GraphWld.tpu Copyright (C) 1989 by Gene Fowler
  2.  
  3. GraphWld.tpu extends Graph.tpu to handle world co-
  4. ordinates by providing parallel drawing procedures
  5. that translate world to viewpoint coordinates and
  6. call the original procedures from Graph. There are
  7. also two standalone translators (one for x,y co-
  8. ordinates and one for dx,dy relative coordinates
  9. or distances) when one translation yields variables
  10. for repeated calls or a parallel procedure would
  11. have to relay extra params.
  12.  
  13. The "central" procedure is CreateWorld(ULx,ULr,LRx,
  14. LRy). The params define your world. This procedure
  15. is called AFTER any defining of a viewport in which
  16. the world will exist and BEFORE any use of the
  17. translating procedures.
  18. }
  19. unit GraphWld; {world coordinates ext. to Graph.tpu}
  20.  
  21. interface
  22.  
  23. uses crt, graph;
  24.  
  25. procedure CreateWorld(ULx, ULy, LRx, LRy : real);
  26.  
  27. procedure w2vp(Var wx, wy : real; var vpx, vpy : integer);
  28.  
  29. procedure w2vpRel(Var wdx, wdy : real; var vpdx, vpdy : integer);
  30.  
  31. procedure w2vpRadius(var wRadius : real; var vpRadius : word; wAspRatio : real);
  32.  
  33. procedure WPutPixel(wx, wy : real);
  34.  
  35. function  WGetPixel(wx, wy : real) : word;
  36.  
  37. procedure WLine(wx1, wy1, wx2, wy2 : real);
  38.  
  39. procedure WRectangle(wx1, wy1, wx2, wy2 : real);
  40.  
  41. procedure WLineTo(wx, wy : real);
  42.  
  43. procedure WMoveTo(wx, wy : real);
  44.  
  45. procedure WLineRel(wdx, wdy : real);
  46.  
  47. procedure WMoveRel(wdx, wdy : real);
  48.  
  49. implementation
  50.  
  51. var
  52.    xv,yv, x1v,y1v,x2v,y2v : integer;
  53.    MaxColor : word;
  54.    RatioX, RatioY : real;
  55.    VPMaxX, VPMaxY : integer;
  56.    ViewP : ViewPortType;
  57.    WXTotal, WXNegAdj, WYTotal, WYNegAdj,
  58.    FTemp : real;
  59.    FlipYFlag : boolean;
  60.    ivpdx, ivpdy : real;
  61.    xAsp, yAsp   : word;
  62.    vpAspRatio : real;
  63.  
  64. procedure CreateWorld{(ULx, ULy, LRx, LRy : real)};
  65.  
  66. begin
  67.    GetViewSettings(ViewP);  {Viewport must be set before world}
  68.    with ViewP do
  69.      begin
  70.        VPMaxX := x2-x1;
  71.        VPMaxY := y2-y1;
  72.      end;
  73.    if ULy > LRy then  { for Cartesian flip; corresponding vpy adjust. in
  74.                         the procedures. }
  75.      begin
  76.        FlipYFlag  := true;
  77.        FTemp      := ULy;
  78.        ULy        := LRy;
  79.        LRy        := FTemp;
  80.      end
  81.    else FlipYFlag := false;
  82.    WXTotal := LRx - ULx + 1;
  83.    if ULx < 0 then WXNegAdj  := Abs(ULx) else WXNegAdj := 0;
  84.    WYTotal := abs(LRy - ULy) + 1;
  85.    if ULy < 0 then WYNegAdj  := Abs(ULy) else WYNegAdj := 0;
  86. end;
  87.  
  88. procedure w2vp{(Var wx, wy : real; var vpx, vpy : integer)};
  89.  
  90. begin
  91.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  92.    wx := wx + WXNegAdj;
  93.    wy := wy + WYNegAdj;
  94.    vpx := round(wx * RatioX); vpy := round(wy * RatioY);
  95.    if FlipYFlag then vpy := VPMaxY - vpy;
  96. end;
  97.  
  98. procedure w2vpRel{(Var wdx, wdy : real; var vpdx, vpdy : integer)};
  99.  
  100. var
  101.    NFlagX : boolean;
  102.    NFlagY : boolean;
  103.  
  104. begin
  105.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  106.    if wdx < 0 then NFlagX := True else NFlagX := False;
  107.    if not FlipYFlag then
  108.      if wdy < 0 then NFlagY := True else NFlagY := False
  109.    else
  110.      if wdy < 0 then NFlagY := False else NFlagY := True;
  111.    wdx := abs(wdx); wdy := abs(wdy);
  112.    vpdx := round(wdx * RatioX); vpdy := round(wdy * RatioY);
  113.    if NFlagX then vpdx := -vpdx;
  114.    if NFlagY then vpdy := -vpdy;
  115. end;
  116.  
  117. procedure w2vpRadius{(var wRadius : real; var vpRadius : word; wAspRatio : real)};
  118.  
  119. var
  120.    wdx, wdy : real;
  121. begin
  122.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  123.    wdx    := sqrt(sqr(wRadius) / (1 + (sqr(wAspRatio))));
  124.    wdy    := wAspRatio * wdx;
  125.    ivpdx := (wdx * RatioX);
  126.    GetAspectRatio(xAsp, yAsp);
  127.    vpAspRatio := xAsp / yAsp;
  128.    ivpdy := (wdy * RatioY) * (wAspRatio / vpAspRatio);
  129.    vpRadius := round(sqrt(sqr(ivpdx) + sqr(ivpdy)));
  130. end;
  131.  
  132. procedure WPutPixel{(wx, wy : real)};
  133.  
  134. begin
  135.  
  136.    wx := wx + WXNegAdj;
  137.    wy := wy + WYNegAdj;
  138.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  139.    xv := round(wx * RatioX); yv := round(wy * RatioY);
  140.    if FlipYFlag then yv := VPMaxY - yv;
  141.    MaxColor := GetMaxColor;
  142.    PutPixel(xv, yv, MaxColor);
  143. end;
  144.  
  145. function WGetPixel{(wx, wy : real) : word};
  146.  
  147. begin
  148.    wx := wx + WXNegAdj;
  149.    wy := wy + WYNegAdj;
  150.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  151.    xv := round(wx * RatioX); yv := round(wy * RatioY);
  152.    if FlipYFlag then yv := VPMaxY - yv;
  153.    WGetPixel := GetPixel(xv, yv);
  154. end;
  155.  
  156. procedure WLine{(wx1, wy1, wx2, wy2 : real)};
  157.  
  158. begin
  159.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  160.    wx1 := wx1 + WXNegAdj;
  161.    wy1 := wy1 + WYNegAdj;
  162.    wx2 := wx2 + WXNegAdj;
  163.    wy2 := wy2 + WYNegAdj;
  164.    x1v := round(wx1 * RatioX); y1v := round(wy1 * RatioY);
  165.    x2v := round(wx2 * RatioX); y2v := round(wy2 * RatioY);
  166.    if FlipYFlag then
  167.      begin
  168.        y1v := VPMaxY - y1v;
  169.        y2v := VPMaxY - y2v;
  170.      end;
  171.    Line(x1v,y1v,x2v,y2v);
  172. end; {WLine}
  173.  
  174. procedure WRectangle{(wx1, wy1, wx2, wy2 : real)};
  175.  
  176. begin
  177.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  178.    wx1 := wx1 + WXNegAdj;
  179.    wy1 := wy1 + WYNegAdj;
  180.    wx2 := wx2 + WXNegAdj;
  181.    wy2 := wy2 + WYNegAdj;
  182.    x1v := round(wx1 * RatioX); y1v := round(wy1 * RatioY);
  183.    x2v := round(wx2 * RatioX); y2v := round(wy2 * RatioY);
  184.    if FlipYFlag then
  185.      begin
  186.        y1v := VPMaxY - y1v;
  187.        y2v := VPMaxY - y2v;
  188.      end;
  189.    Rectangle(x1v,y1v,x2v,y2v);
  190. end; {WRectangle}
  191.  
  192. procedure WLineTo{(wx, wy : real)};
  193.  
  194. begin
  195.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  196.    wx := wx + WXNegAdj;
  197.    wy := wy + WYNegAdj;
  198.    xv := round(wx * RatioX); yv := round(wy * RatioY);
  199.    if FlipYFlag then yv := VPMaxY - yv;
  200.    LineTo(xv,yv);
  201. end; {WLineTo}
  202.  
  203. procedure WMoveTo{(wx, wy : real)};
  204.  
  205. begin
  206.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  207.    wx := wx + WXNegAdj;
  208.    wy := wy + WYNegAdj;
  209.    xv := round(wx * RatioX); yv := round(wy * RatioY);
  210.    if FlipYFlag then yv := VPMaxY - yv;
  211.    MoveTo(xv,yv);
  212. end; {WMoveTo}
  213.  
  214. procedure WLineRel{(wdx, wdy : real)};
  215.  
  216. var
  217.    NFlagX : boolean;
  218.    NFlagY : boolean;
  219.  
  220. begin
  221.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  222.    if wdx < 0 then NFlagX := True else NFlagX := False;
  223.    if not FlipYFlag then
  224.      if wdy < 0 then NFlagY := True else NFlagY := False
  225.    else
  226.      if wdy < 0 then NFlagY := False else NFlagY := True;
  227.    wdx := abs(wdx); wdy := abs(wdy);
  228.    xv := round(wdx * RatioX); yv := round(wdy * RatioY);
  229.    if NFlagX then xv := -xv;
  230.    if NFlagY then yv := -yv;
  231.    LineRel(xv,yv);
  232. end;  {WLineRel}
  233.  
  234. procedure WMoveRel{(wdx, wdy : real)};
  235.  
  236. var
  237.    NFlagX : boolean;
  238.    NFlagY : boolean;
  239.  
  240. begin
  241.    RatioX := (VPMaxX + 1) / WXTotal; RatioY := (VPMaxY + 1) / WYTotal;
  242.    if wdx < 0 then NFlagX := True else NFlagX := False;
  243.    if not FlipYFlag then
  244.      if wdy < 0 then NFlagY := True else NFlagY := False
  245.    else
  246.      if wdy < 0 then NFlagY := False else NFlagY := True;
  247.    wdx := abs(wdx); wdy := abs(wdy);
  248.    xv := round(wdx * RatioX); yv := round(wdy * RatioY);
  249.    if NFlagX then xv := -xv;
  250.    if NFlagY then yv := -yv;
  251.    MoveRel(xv,yv);
  252. end;  {WMoveRel}
  253.  
  254. end.
  255.  
  256.